; Muster Text 1 - Basic
(setf my-text
     (make-array 12 :adjustable t :initial-contents
                 '(("a" 0   100 0  20)
                   ("g" 200 100 0  20)
                   ("b" 120 220 0  20)
                   ("c" 240 340 0  70)
                   ("d" 0   100 30 50)
                   ("e" 120 220 30 50)
                   ("h" 100 340 30 10)
                   ("f" 240 340 30 10)
                   ("hoho" 0 100 60 80)
                   ("xline" 0 120 130 150)
                   ("xline 2" 0 140 160 180)
                   ("xline 3" 0 130 190 210) )))

(defparameter *arr* (make-array 0 :adjustable t))

(setf my-text-two-column
     (make-array 36 :adjustable t :initial-contents
                 '(("i" 0 10 0 20)
                   ("have" 20 60 0  20)
                   ("a" 70 81 0 20)
                   ("little" 90 150 0 20)
                   ("dog." 0 30 30 50)
                   ("and" 41 70 30 50)
                   ("his" 80 110 30 50)
                   ("name" 120 160 30 50)
                   ("is" 0 30 60 80)
                   ("bingo." 41 100 60 80)

                   ("i" 200 210 0 20)
                   ("don't" 220 270 0 20)
                   ("have" 280 320 0 20)
                   ("any" 330 361 0 20)
                   ("funny" 200 250 30 50)
                   ("cat." 260 301 30 50)
                   ("So" 310 330 30 50)
                   ("i" 340 350 30 50)
                   ("am" 200 220 60 80)
                   ("alone." 230 290 60 80)

                   ("good" 0 41 140 160)
                   ("bye" 50 80 140 160)
                   ("teacher." 91 170 140 160)
                   ("here" 180 220 140 160)
                   ("is" 231 251 140 160)
                   ("your" 261 300 140 160)
                   ("song." 311 360 140 160)

                   ("erhan" 0 51 170 190)

                   ("Ferner" 0 61 220 240)
                   ("Kamp" 71 111 220 240)
                   ("8" 121 131 220 240)
                   ("22177" 0 52 250 270)
                   ("Hamburg" 63 133 250 270)

                   ("Tel:" 320 362 220 240)
                   ("79305245" 281 362 250 270)
                   ("040" 251 271 220 240)
                    )))

; open file
(defparameter *f* (open "/home/bagdemir/Desktop/muster" :if-does-not-exist nil))
; horizontal tolerence
(defparameter *tol* 1)
; vertical tolerance

(defun t-eql (e1 e2)
  (if (> *tol* (abs (- e1 e2)))
      t
    nil))

(defun write-to-file (name content)
  (with-open-file
   (stream name
           :external-format
           charset:iso-8859-1
           :direction :output
           :if-exists :overwrite
           :if-does-not-exist :create)
   (format stream content))
  name)

(defun read-text-from ()
  (let ((in *f*))
    (when in
      (loop for line = (read-line in nil)
            while line do
            (progn
              (adjust-array *arr* (1+ (array-total-size *arr*)))
              (setf (aref *arr* (1- (array-total-size *arr*))) (read-from-string line))))
      (close in))))

(read-text-from)

; Compare funktionen
; Die werden in den Sort- Methoden verwendet.
(defun compare-cluster (e1 e2)
 (and (eql (second e1) (second e2))
      (< (third e1) (third e2)) t))

(defun compare-mix (obj1 obj2)
  (if (cluster? obj1)
     (setf val1 (third obj1))
   (setf val1 (fourth obj1)))
 (if (cluster? obj2)
     (setf val2 (third obj2))
   (setf val2 (fourth obj2)))
 (and (< val1 val2)
      t))

(defun overlapping?-struct (y1_0 y1_1 y2_0 y2_1)
  (setf not-overlapping?
        (or
         (and
          (> y1_0 y2_1)
          (> y1_1 y2_1)
          t)
         (and
          (< y1_0 y2_0)
          (< y1_1 y2_0)
          t)))
  (not not-overlapping?))

(defun overlapping? (word1 word2)
  "finds out if the word is overlapping with the predessor"
  (let ((y1_0 (fourth word1)) (y1_1 (fifth word1))
        (y2_0 (fourth word2)) (y2_1 (fifth word2))
        (overlapping? t))
    (setf overlapping?
          (or
           (and
            (> y1_0 y2_1)
            (> y1_1 y2_1)
            t)
           (and
            (< y1_0 y2_0)
            (< y1_1 y2_0)
            t)))
    (not overlapping?)))

(defun cluster? (el)
  (and (listp el) (> (length el) 5) t))

(defun word? (el)
  (and (listp el) (< (length el) 6) t))

(defun compare-generic2 (o1 o2)
  (let((y1_0 -1) (y1_1 -1) (y2_0 -1) (y2_1 -1))
    (if (cluster? o1)
        (progn
          (setf y1_0 (third o1))
          (setf y1_1 (fourth o1)))
      (progn
        (setf y1_0 (fourth o1))
        (setf y1_1 (fifth o1))))
    (if (cluster? o2)
        (progn
          (setf y2_0 (third o2))
          (setf y2_1 (fourth o2)))
      (progn
        (setf y2_0 (fourth o2))
        (setf y2_1 (fifth o2))))
    (and (overlapping?-struct y1_0 y1_1 y2_0 y2_1)
         (< (second o1) (second o2))
         t)))

(defun compare-generic (o1 o2)
  (let ((weight1 0) (weight2 0))
    (if (cluster? o1)
        (setf weight1 (+ (second o1) (* 10 (third o1)) ))
      (setf weight1 (+ (second o1) (* 10 (fourth o1)))))
    (if (cluster? o2)
        (setf weight2 (+ (second o2) (* 10 (third o2))))
      (setf weight2 (+ (second o2) (* 10 (fourth o2)) )))
    (< weight1 weight2)))

(defun is-cluster (el)
 (and (listp el) (> (length el) 5) t))

(defun is-word (el)
 (and (listp el) (< (length el) 6) t))

(defun compare-func1 (e1 e2)
  (and (overlapping? e1 e2)
       (< (second e1) (second e2))
       t))

(defun compare-func2 (e1 e2)
 (and (t-eql (second e1) (second e2))
      (< (fifth e1) (fifth e2)) t))

(defun compare-func3 (e1 e2)
 (and (eql (third e1) (third e2))
      (< (fifth e1) (fifth e2)) t))

(defun font-size (word)
  (if (null word)
      nil
    (- (fifth word) (fourth word))))


(defun wider? (word1 word2)
  (let ((width1 (- (third word1) (second word1)))
        (width2 (- (third word2) (second word2))))
    (if (> width1 width2)
        word1
      word2)))

(defun overlapping-words? (word1 word2 txt)
  "word overlapping analyse"
  (let ((size (array-total-size txt))
        (x1_0 (second word1))
        (x1_1 (third word1))
        (x2_0 (second word2))
        (x2_1 (third word2))
        (y1_1 (fifth word1))
        (y2_0 (fourth word2))
        (wider-word (wider? word1 word2)))
    (loop for i from 0 to (1- size) do
          (let* ((curr (aref txt i)))
            (and ; if the word lies between two words in vertical
             (> (fourth curr) y1_1)
             (< (fourth curr) y2_0)
             (progn
               (or
                ;; overlapping 1. if current word's x0 greater than wider's x0 'and'
                ;; smaller than wider's x1;
                (and
                 (> (second curr) (second wider-word))
                 (< (second curr) (third wider-word))
                 )
                ;; overlapping 2. if current word's x1 greater than wider's x0
                ;; 'and' smaller than wider's x1 
                (and
                 (> (third curr) (second wider-word))
                 (< (third curr) (third wider-word))
                 )
                ;; overlapping 3. if current word's x0 is smaller than wider's and
                ;; current words x1 is greater than wider's
                (and
                 (< (second curr) (second wider-word))
                 (> (third curr) (third wider-word))
                 )
                (and
                 (> (second curr) (second wider-word))
                 (< (third curr) (third wider-word))
                 )
                
                ))
             (return t))))))

; Sortiert den Text nach gegebenen Sort- Funktionen
; Bubblesort
(defun sort-text (lst func-comp first-sort-func)
 ; sorts according-to-y-sorted-list with bubble sort.
  (let ((result (sort (copy-seq lst) #'< :key first-sort-func)))
    ;; any other idea to reduce O(n^2) time complexity?
    ;; binary search tree does give a better result? what about
    ;; binary-search tree construction?
    (loop for i from (1- (length result)) downto 0 do
          (loop for j from 0 to i
                when (funcall func-comp (aref result i) (aref result j))
                do (rotatef (aref result i) (aref result j)) ))
    result))

; Sucht nach Clustern im Cluster- Array.
(defun find-cluster (cluster-arr x type)
 ; searchs for clusters with x coordinate on a x-line
 (and (arrayp cluster-arr)
      (> (array-total-size cluster-arr) 0)
      (let ((result nil) (arr-size (array-total-size cluster-arr)))
        (loop for i from 0 to (1- arr-size) do
              (and
                (t-eql (second (aref cluster-arr i)) x) ; x tol
                (eql type (fifth (aref cluster-arr i)))
                (setf result (aref cluster-arr i)))) result)))

; Die Methode fügt ein neues Element ins Array hinzu.
(defun append-to-cluster-arr (cluster element)
 "appends a new element"
 (if (arrayp cluster)
     (progn
       (adjust-array cluster (1+ (array-total-size cluster)))
       (setf (aref cluster (1- (array-total-size cluster))) element))))

; Entscheidung, ob ein neues Cluster erzeugt wird, oder das
; Existierende angepasst werden soll.
(defun process-cluster (x-line cluster y-prev y-curr cluster-arr type)
  "creates cluster creation or change the vertical length of a cluster"
  (let* ((distance (sixth cluster)) (cluster-y-end (fourth cluster)))
    (if (null cluster)
        (append-to-cluster-arr
         cluster-arr
         (list (concatenate 'string "cluster-(" (write-to-string x-line) ")")
               x-line
               y-prev
               y-curr
               type (- y-curr y-prev) :words nil))
      (if (eql distance 0)
          (progn
            (setf (fourth cluster) y-curr)
            ;; set new distance
            (setf (sixth cluster) (- y-curr y-prev)))
        (if (t-eql distance (- y-curr (fourth cluster)))
            (progn
              (print "***************** distance eql")
              (fourth cluster) y-curr)
          (append-to-cluster-arr
           cluster-arr
           (list (concatenate 'string "cluster-(" (write-to-string x-line) ")")
                 x-line
                 y-curr
                 y-curr
                 type 0 :words nil)))))))

; Diese Funktion berechnet Cluster- Layout
                                        ; Diese Funktion berechnet Cluster- Layout
(defun create-cluster-layout (txtarr)
  (let* ((s (array-total-size txtarr))
         (source-toleft  (sort-text txtarr #'compare-func2 #'second))
         (source-toright (sort-text txtarr #'compare-func3 #'third))
         (cluster-arr (make-array 0 :adjustable t)))
    (loop for i from 1 to (1- s) do
          (cond
           ((t-eql (second (aref source-toleft i)) (second (aref source-toleft (1- i))))
            (let*
                ((word (aref source-toleft i))
                 (word-prev (aref source-toleft (1- i)))
                 (x-line  (second word-prev))
                 (cluster-found (find-cluster cluster-arr (- x-line 3) :LEFT))
                 (y-end-prev (fifth (aref source-toleft (1- i))))
                 (y-end-curr (fifth (aref source-toleft i)))
                 (distance (sixth cluster-found)))
              (if (overlapping-words? word-prev word source-toleft)
                  nil
                (process-cluster x-line cluster-found y-end-prev y-end-curr cluster-arr :LEFT))
              ))
           ((t-eql (third  (aref source-toright i)) (third  (aref source-toright (1- i))))
            (let*
                ((word (aref source-toleft i))
                 (word-prev (aref source-toleft (1- i)))
                 (x-line (third (aref source-toright (1- i))))
                 (cluster-found (find-cluster cluster-arr (+ x-line 3) :RIGHT))
                 (y-end-prev (fifth (aref source-toright (1- i))))
                 (y-end-curr (fifth (aref source-toright i)))
                 (distance (sixth cluster-found)))
              (if (overlapping-words? word-prev word source-toleft)
                  nil
                (process-cluster x-line cluster-found y-end-prev y-end-curr cluster-arr :RIGHT))
              ))))
        cluster-arr))

(defun find-right-most-cluster (word cluster-layout)
  "searchs for a right cluster of the world given."
  (let ((x (third word))
        (y (fifth word))
        (result nil)
        (distance-list (list nil 10000))
        (size (array-total-size cluster-layout)))
    ; iterate over cluster layout array
    (loop for i from 0 to (1- size) do
          (let* ((cluster (aref cluster-layout i)) (xline (second cluster)))
            (if (<= x xline)
                (progn
                  (setf dist (- xline x))
                  (and 
                       (eql (fifth cluster) :RIGHT)
                       (>= y (third cluster))
                       (<= y (fourth  cluster))
                       (<  dist (second distance-list))
                       (progn
                         (setf (first  distance-list) cluster)
                         (setf (second distance-list) (- xline x))
                         (setf result cluster))))))) distance-list))

; Sucht nach Cluster - Boundry (auf der Linkenseite) im Cluster-Layout
; Array liegt als nächste zum Wort.
(defun find-left-most-cluster (word cluster-layout)
 "searchs for a cluster which lies on most- left to the word"
 (let ((x (second word)) (y (fifth word)) (result nil) (distance-list (list nil 10000)) (size (array-total-size cluster-layout)))
   (loop for i from 0 to (1- size) do
         (let* ((cluster (aref cluster-layout i)) (xline (second cluster)))
           (if (>= x xline)
               (progn
                 (setf dist (- x xline))
                 (and (>= x xline)
                    (eql (fifth cluster) :LEFT)
                    (>= y (- (third cluster) *tol*)) ; with tolarence
                    (<= y (+ (fourth cluster) *tol*))
                    (<  dist (second distance-list))
                    (progn
                      (setf (first  distance-list) cluster)
                      (setf (second distance-list) (- x xline))
                      (setf result cluster)
                      )))))) distance-list))

(defun add-word (cluster word)
  "adds a new word into the cluster"
  (let ((cluster-words (eighth cluster)))
    (if (null cluster-words)
        (setf (eighth cluster) (list word))
      (setf (cdr (last (nth 7 cluster))) (list word)))))

(defvar x-const 3)

; Erzeugt einen formatierten Text  (Mit Spalten)
(defun create-formated-text(txt)
  (let* ((sorted-text (sort-text txt #'compare-func1 #'fifth))
         (cluster-layout (sort-text (create-cluster-layout txt) #'compare-cluster #'second))
         (size (array-total-size txt))
         (result (list))
         (x-def nil)
         (word-before nil)
         (distance-x nil)
         (last-word-positioning :left))
    ;iterate over words
    (loop for i from 0 to (1- size) do
          (let* ((word (aref sorted-text i))
                 (left-cluster (first (find-left-most-cluster word cluster-layout)))
                 (right-cluster (first (find-right-most-cluster word cluster-layout)))
                 (cluster-words-left (eighth left-cluster))
                 (cluster-words-right (eighth right-cluster))
                 (expected-distance (* x-const (- (fifth word) (fourth word)))))
            
            (if (null word-before)
                nil
              ; if the words lay on the same row
              (if (overlapping? word word-before)
                  ;; set wording distance 
                  (setf distance-x (- (second word) (third word-before)))
                (progn
                  (setf distance-x nil)
                  (setf word-before nil))))
            ;; (print distance-x)
            (cond ((and
                    (null left-cluster)
                    (null right-cluster)) (push word result))
                  ;; there is no left cluster on the line
                  ((null left-cluster)
                   (add-word right-cluster word))
                  ;; there is no right cluster on the line
                  ((null right-cluster)
                   (add-word left-cluster word))
                  ;; default case, the word has both left and right cluster
                  ((null nil)
                   (cond
                    ((null distance-x)
                     ;; if wording distance is not calculated yet.
                     (add-word left-cluster word)
                     (setf last-word-positioning :left))
                    ((> distance-x expected-distance)
                     (add-word right-cluster word)
                     (setf last-word-positioning :right))
                    ((null nil)
                     (add-word left-cluster word))
                    )))
            (setf word-before word)))
    (setf result-lst (append result (coerce cluster-layout 'list)))
    (sort-text
     (make-array
      (length result-lst)
      :initial-contents
      result-lst)
     #'compare-mix
     #'second)))

; Prints formatted text
(defun print-formatted-text(txt)
 (let ((size (array-total-size txt)) (sorted (sort (sort txt #'compare-mix) #'compare-generic2)) (result "")) 
   (loop for i from 0 to (1- size) do
         (if (is-word (aref sorted i))
             ; (print (first (aref sorted i)))
             (concatenate 'string result (first (aref sorted i)) " ")
           (if (null (nth 7 (aref sorted i)))
               nil
             (progn
               (setf result (concatenate 'string result " "))
               (dolist (curr (nth 7 (aref sorted i)))
                 (setf result (concatenate 'string result (first curr) " "))
                 ))
             )))
   result))

; (print (overlapping?-struct 1435 1474 1335 1375))

                                        ; (print (sort-text *arr* #'compare-func1 #'fifth))
(print (sort-text *arr* #'compare-func3 #'third))
; Cluster-Layout
(setf cluster-arr (create-cluster-layout *arr*))
(print cluster-arr)


(setf w1 '("r" 1521 1545 1335 1374))
(setf w2 '("Neugründung" 1295 1547 1640 1679))


(setf mytestarr (make-array 3 :initial-contents
                            '(("r" 1521 1545 1335 1374)
                              ("Neugründung" 1295 1547 1640 1679)
                              ("mit" 1513 1583 1440 1476)
                              )
                            ))


(print (overlapping-words? w2 w1 mytestarr))
; (print (find-cluster cluster-arr 0 :LEFT))
; 3 Cluster / Text
(print (create-formated-text *arr*))
; Das Ergebnis
; (print (print-formatted-text (create-formated-text *arr*)))
; (write-to-file "/home/bagdemir/Desktop/output.txt"
;               (print-formatted-text (create-formated-text *arr*)))
; END
